unit DUnitX.NUnit25.ResultsLog.Solution;
interface
uses Classes, DUnitX.NUnit, SBD.ServiceProvider;
type

TNUnit25_ResultsLog = class( TInterfacedObject, INUnit25_ResultsLog)
  private
    [Injection('UTF-8')] FXMLWriter: IXMLWriter;
    function OpenLog( OutStream1: TStream;
      const ProgName: string;
      RunStamp: TDateTime;
      Total, Failed, Errored, NotRun, Ignored, Skipped: integer;
      RunResult: TNUnitResult;
      GrossDuration: double)
      : INUnit25_TestSuite; // units of days.
    procedure CloseLog;

  private
    FDoc: IXMLWriter_Document;

  public
    [Configuration] constructor ServiceModeCreate;
  end;


procedure RegisterServices( const Provider: IServiceProvider);

implementation













uses SysUtils, DUnitX.Utils.XML2;

procedure RegisterServices( const Provider: IServiceProvider);
begin
Provider.RegisterServiceClass( INUnit25_ResultsLog, TNUnit25_ResultsLog)
end;


type
TTestSuite = class abstract( TInterfacedObject, INUnit25_TestSuite)
  protected
    FParent: INUnit25_TestSuite;
    FElement: IXMLWriter_Element;

    procedure AddAttribute( const Name, Value: string);            overload;
    procedure AddAttribute( const Name: string; Value: integer);   overload;
    procedure AddAttribute( const Name: string; Value: boolean);   overload;
    procedure AddAttribute( const Name: string; DurationValue: double);   overload;
    procedure AddAttribute( const Name: string; Value: TNUnitResult);   overload;
    procedure AddSuccessAttribute( Value: TNUnitResult);
    procedure AddOptionalAttribute( const Name, Value: string);
    procedure PushElement( const ElementName: string);
    procedure PopElement;
    procedure AddTextedElement( const ElementName, Content: string);
    procedure AddMessage( const Content: string);

    function AddNamespaceSuite(
      const Name: string; Executed: boolean; NetResult: TNUnitResult;
      Time: double; Asserts: integer): INUnit25_TestSuite;          virtual; abstract;

    function AddFixtureSuite(
      const Name, Description: string; Executed: boolean; NetResult: TNUnitResult;
      Time: double; Asserts: integer;
      const Reason: string): INUnit25_TestSuite;                    virtual; abstract;

    procedure AddTestCase(
      const Name, Description: string; Executed: boolean; CaseResult: TNUnitResult;
      Time: double; Asserts: integer;
      const Reason: string);                                        virtual; abstract;

    function Close: INUnit25_TestSuite;                             virtual; abstract;

    procedure PushTestElement(
      const ElementName, Name, Description: string; Executed: boolean;
      RunResult: TNUnitResult; Duration: double; Asserts: integer);

  public
    constructor Create( const Parent1: INUnit25_TestSuite);
  end;

TGroup = class ( TTestSuite)
  protected
    function AddNamespaceSuite(
      const Name: string; Executed: boolean; NetResult: TNUnitResult;
      Time: double; Asserts: integer): INUnit25_TestSuite;  override;

    function AddFixtureSuite(
      const Name, Description: string; Executed: boolean; NetResult: TNUnitResult;
      Time: double; Asserts: integer;
      const Reason: string): INUnit25_TestSuite;                             override;

    procedure AddTestCase(
      const Name, Description: string; Executed: boolean; CaseResult: TNUnitResult;
      Time: double; Asserts: integer;
      const Reason: string);                                                 override;

    function Close: INUnit25_TestSuite;                                      override;

  public
    constructor CreateGeneric( const Parent1: INUnit25_TestSuite;
     const ParentElement: IXMLWriter_Element;
     const TestSuiteType, Name, Description: string; Executed: boolean;
     RunResult: TNUnitResult; GrossDuration: Double; Asserts: integer;
     const Reason: string);

    constructor CreateAssembly(
     const ParentElement: IXMLWriter_Element;
     const ProgName: string; RunResult: TNUnitResult; GrossDuration: Double);

    constructor CreateNamespace( const Parent1: INUnit25_TestSuite;
     const ParentElement: IXMLWriter_Element;
     const Name: string; Executed: boolean;
     RunResult: TNUnitResult; GrossDuration: Double; Asserts: integer);
  end;

TFixture = class ( TGroup)
  protected
    procedure AddTestCase(
      const Name, Description: string; Executed: boolean; CaseResult: TNUnitResult;
      Time: double; Asserts: integer;
      const Reason: string);                                                 override;

  public
    constructor CreateFixture( const Parent1: INUnit25_TestSuite;
     const ParentElement: IXMLWriter_Element;
     const Name, Description: string; Executed: boolean;
     RunResult: TNUnitResult; GrossDuration: Double; Asserts: integer;
     const Reason: string);
  end;

TTestCase = class ( TTestSuite)
  protected
    function AddNamespaceSuite(
      const Name: string; Executed: boolean; NetResult: TNUnitResult;
      Time: double; Asserts: integer): INUnit25_TestSuite;  override;

    function AddFixtureSuite(
      const Name, Description: string; Executed: boolean; NetResult: TNUnitResult;
      Time: double; Asserts: integer;
      const Reason: string): INUnit25_TestSuite;                             override;

    procedure AddTestCase(
      const Name, Description: string; Executed: boolean; CaseResult: TNUnitResult;
      Time: double; Asserts: integer;
      const Reason: string);                                                 override;

    function Close: INUnit25_TestSuite;                                      override;

  public
    constructor Create( const Parent1: INUnit25_TestSuite;
     const ParentElement: IXMLWriter_Element;
     const Name, Description: string; Executed: boolean;
     RunResult: TNUnitResult; GrossDuration: Double; Asserts: integer);
  end;


function EncodeResult( NUnitResult: TNUnitResult): string;
const
  ResultStrings: array[ TNUnitResult] of string = (
    'Failure', 'Success', 'Ignored', 'Error', 'Inconclusive', 'NotRunnable');
begin
result := ResultStrings[ NUnitResult]
end;

function EncodeDuration( Duration: double): string;
begin
result := Format( '%.3f', [Duration])
end;


constructor TNUnit25_ResultsLog.ServiceModeCreate;
begin
end;

procedure TNUnit25_ResultsLog.CloseLog;
begin
FDoc.Close
end;

function TNUnit25_ResultsLog.OpenLog(
      OutStream1: TStream;
      const ProgName: string;
      RunStamp: TDateTime;
      Total, Failed, Errored, NotRun, Ignored, Skipped: integer;
      RunResult: TNUnitResult;
      GrossDuration: double): INUnit25_TestSuite;
var
  El: IXMLWriter_Element;
  ErrorCount: integer;
  FailureCount: integer;

  procedure AddAttribute( const Name, Value: string); overload;
  begin
  El.AddAttribute( '', Name, Value)
  end;

  procedure AddAttribute( const Name: string; Value: integer); overload;
  begin
  AddAttribute( Name, Txs_integer.Encode( Value))
  end;

begin
FDoc := FXMLWriter.OpenDocument( OutStream1);
El := FDoc.AddElement( '', 'test-results');
AddAttribute( 'name', ProgName);
AddAttribute( 'total', Total);
ErrorCount   := 0;
FailureCount := 0;
case RunResult of
  rFailure: FailureCount := 1;
  rError  : ErrorCount   := 1;
  end;
AddAttribute( 'errors', ErrorCount);
AddAttribute( 'failures', FailureCount);
AddAttribute( 'not-run', NotRun);
AddAttribute( 'inconclusive', 0);
AddAttribute( 'ignored', Ignored);
AddAttribute( 'skipped', Skipped);
AddAttribute( 'invalid', 0);
AddAttribute( 'date', Txs_dateTime.EncodeDate( Trunc( RunStamp)));
AddAttribute( 'time', Txs_dateTime.EncodeTime( Frac( RunStamp), False, 0));
El := El.AddElement( '', 'environment');
AddAttribute( 'nunit-version','2.5.8.0');
AddAttribute( 'clr-version','2.0.50727.1433');
AddAttribute( 'os-version','(to be developed)');
AddAttribute( 'platform','(to be developed)');
AddAttribute( 'cwd','(to be developed)');
AddAttribute( 'machine-name','(to be developed)');
AddAttribute( 'user','(to be developed)');
AddAttribute( 'user-domain','(to be developed)');
El := El.Close as IXMLWriter_Element;
El := El.AddElement( '', 'culture-info');
AddAttribute( 'current-culture','en');
AddAttribute( 'current-uiculture','en');
El := El.Close as IXMLWriter_Element;
result := TGroup.CreateAssembly( El, ProgName, RunResult, GrossDuration)
end;


procedure TTestSuite.AddAttribute( const Name, Value: string);
begin
FELement.AddAttribute( '', Name, Value)
end;

procedure TTestSuite.AddAttribute( const Name: string; Value: boolean);
begin
AddAttribute( Name, Txs_boolean.Encode( Value))
end;

procedure TTestSuite.AddAttribute( const Name: string; Value: integer);
begin
AddAttribute( Name, Txs_integer.Encode( Value))
end;

procedure TTestSuite.AddAttribute( const Name: string; Value: TNUnitResult);
begin
AddAttribute( Name, EncodeResult( Value))
end;

procedure TTestSuite.AddTextedElement( const ElementName, Content: string);
begin
PushElement( ElementName);
FElement.AddTextNode( Content);
PopElement
end;


procedure TTestSuite.AddMessage( const Content: string);
begin
AddTextedElement( 'message', Content)
end;

procedure TTestSuite.AddAttribute( const Name: string; DurationValue: double);
begin
AddAttribute( Name, EncodeDuration( DurationValue))
end;

procedure TTestSuite.AddOptionalAttribute( const Name, Value: string);
begin
if Value <> '' then
  AddAttribute( Name, Value)
end;

procedure TTestSuite.AddSuccessAttribute( Value: TNUnitResult);
begin
AddAttribute( 'success', Value = rSuccess)
end;

constructor TTestSuite.Create(
  const Parent1: INUnit25_TestSuite);
begin
FParent := Parent1
end;

procedure TTestSuite.PushElement( const ElementName: string);
begin
FElement := FElement.AddElement( '', ElementName)
end;

procedure TTestSuite.PushTestElement(
  const ElementName, Name, Description: string;
  Executed: boolean; RunResult: TNUnitResult; Duration: double; Asserts: integer);
begin
PushElement( ElementName);
AddAttribute( 'name', Name);
AddOptionalAttribute( 'description', Description); // Only valid for 'TestFixture'
AddAttribute( 'executed', Executed);
AddAttribute( 'result', RunResult);
AddSuccessAttribute( RunResult);
AddAttribute( 'time', Duration);
AddAttribute( 'asserts', Asserts)
end;



procedure TTestSuite.PopElement;
begin
if not Supports( FElement.Close, IXMLWriter_Element, FElement) then
  FElement := nil
end;

{ TGroup }

constructor TGroup.CreateAssembly(
  const ParentElement: IXMLWriter_Element;
  const ProgName: string; RunResult: TNUnitResult;
  GrossDuration: Double);
begin
CreateGeneric( nil, ParentElement, 'Assembly', ProgName, '', True, RunResult, GrossDuration, 0, '')
end;

constructor TGroup.CreateGeneric(
  const Parent1: INUnit25_TestSuite;
  const ParentElement: IXMLWriter_Element;
  const TestSuiteType, Name, Description: string; Executed: boolean;
  RunResult: TNUnitResult; GrossDuration: Double; Asserts: integer;
  const Reason: string);
begin
inherited Create( Parent1);
FElement := ParentElement;
PushTestElement( 'test-suite', Name, Description, Executed, RunResult, GrossDuration, Asserts);
AddAttribute( 'type', TestSuiteType); // Either 'Assembly', 'Namespace' or 'TestFixture'
if Reason <> '' then  // Only valid for 'TestFixture'
  begin
  PushElement( 'reason');
  AddMessage( Reason);
  PopElement
  end;
PushElement( 'results')
end;


constructor TGroup.CreateNamespace(
  const Parent1: INUnit25_TestSuite;
  const ParentElement: IXMLWriter_Element; const Name: string;
  Executed: boolean; RunResult: TNUnitResult; GrossDuration: Double;
  Asserts: integer);
begin
CreateGeneric( Parent1, FElement, 'Namespace', Name, '', Executed,
               RunResult, GrossDuration, Asserts, '')
end;

function TGroup.AddNamespaceSuite( const Name: string; Executed: boolean;
  NetResult: TNUnitResult; Time: double;
  Asserts: integer): INUnit25_TestSuite;
begin
result := TGroup.CreateNamespace( self, FElement, Name, Executed, NetResult, Time, Asserts)
end;

function TGroup.AddFixtureSuite( const Name, Description: string; Executed: boolean;
  NetResult: TNUnitResult; Time: double; Asserts: integer;
  const Reason: string): INUnit25_TestSuite;
begin
result := TFixture.CreateFixture( self, FElement, Name, Description, Executed, NetResult, Time, Asserts, Reason)
end;

procedure TGroup.AddTestCase( const Name, Description: string; Executed: boolean;
  CaseResult: TNUnitResult; Time: double; Asserts: integer;
  const Reason: string);
begin
raise Exception.Create( 'Test cases cannot be direct children of Namespace groups.')
end;

function TGroup.Close: INUnit25_TestSuite;
begin
(FElement.Close as IXMLWriter_Element) // closes <results>
// Now we are at <test-suite>
.Close; // closes <test-suite>
// Now we are at original parent
result := FParent
end;



{ TFixture }

constructor TFixture.CreateFixture(const Parent1: INUnit25_TestSuite;
  const ParentElement: IXMLWriter_Element;
  const Name, Description: string; Executed: boolean; RunResult: TNUnitResult;
  GrossDuration: Double; Asserts: integer; const Reason: string);
begin
inherited CreateGeneric(
  Parent1, ParentElement, 'TestFixture', Name, Description, Executed,
  RunResult, GrossDuration, Asserts, Reason)
end;




procedure TFixture.AddTestCase(
  const Name, Description: string; Executed: boolean; CaseResult: TNUnitResult;
  Time: double; Asserts: integer; const Reason: string);
var
  TestCase: INUnit25_TestSuite;
begin
TestCase := TTestCase.Create( self, FElement, Name, Description, Executed, CaseResult, Time, Asserts);
if Reason <> '' then
  begin
  if CaseResult = rFailure then
      begin
      PushElement( 'failure');
      AddMessage( Reason);
      AddTextedElement( 'stack-trace', 'Not implemented')
      end
    else
      begin
      PushElement( 'reason');
      AddMessage( Reason)
      end;
  PopElement // reason/failure
  end;
TestCase.Close
end;




{ TTestCase }

constructor TTestCase.Create( const Parent1: INUnit25_TestSuite;
  const ParentElement: IXMLWriter_Element;
  const Name, Description: string; Executed: boolean; RunResult: TNUnitResult;
  GrossDuration: double; Asserts: integer);
begin
// <test-case name="NUnit.Tests.Assemblies.MockTestFixture.FailingTest"
//  executed="True" result="Failure" success="False" time="0.013" asserts="0">
inherited Create( Parent1);
FElement := ParentElement;
PushTestElement( 'test-case', Name, Description, Executed, RunResult, GrossDuration, Asserts)
end;

function TTestCase.Close: INUnit25_TestSuite;
begin
PopElement; // closes <test-case>
// Now we are at original parent
result := FParent
end;

function TTestCase.AddFixtureSuite(const Name, Description: string; Executed: boolean;
  NetResult: TNUnitResult; Time: double; Asserts: integer;
  const Reason: string): INUnit25_TestSuite;
begin
raise Exception.Create( 'Test cases cannot have children.')
end;

function TTestCase.AddNamespaceSuite(const Name: string; Executed: boolean;
  NetResult: TNUnitResult; Time: double;
  Asserts: integer): INUnit25_TestSuite;
begin
raise Exception.Create( 'Test cases cannot have children.')
end;

procedure TTestCase.AddTestCase(const Name, Description: string; Executed: boolean;
  CaseResult: TNUnitResult; Time: double; Asserts: integer;
  const Reason: string);
begin
raise Exception.Create( 'Test cases cannot have children.')
end;



end.
